perm filename BENCH.CL[TIM,LSP]1 blob
sn#719125 filedate 1983-07-11 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00019 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00004 00002 BOYER
C00026 00003 BROWSE -- Benchmark to create and browse through an AI-like data base of units.
C00033 00004 CTAK -- A version of the TAKeuchi function that tests the CATCH/THROW facility.
C00034 00005 DDERIV -- The Common Lisp version of a symbolic derivative benchmark, written
C00037 00006 DESTRU -- Destructive operation benchmark
C00039 00007 DIV2 -- Benchmark which divides by 2 using lists of n ()'s.
C00041 00008 FFT -- This is an FFT benchmark written by Harry Barrow.
C00046 00009 FPRINT -- Benchmark to print to a file.
C00049 00010 FREAD -- Benchmark to read from a file.
C00051 00011 FRPOLY -- Benchmark from Berkeley based on polynomial arithmetic.
C00060 00012 PUZZLE --
C00067 00013 STAK -- The TAKeuchi function with special variables instead of parameter passing.
C00068 00014 TAK -- A vanilla version of the TAKeuchi function and one with tail recursion
C00070 00015 TAKL -- The TAKeuchi function using lists as counters.
C00071 00016 TAKR -- 100 function (count `em) version of TAK that tries to defeat cache
C00094 00017 TPRINT -- Benchmark to print and read to the terminal.
C00096 00018 TRAVERSE -- Benchmark which creates and traverses a tree structure.
C00101 00019 TRIANG --
C00106 ENDMK
C⊗;
;;; BOYER
;;; Common Lisp version.
;;; A Common Lisp package seems to be the safest way to redefine ZetaLisp functions.
;;; This is not for running actual benchmarks on Lisp Machines, just for testing the
;;; translation. Consider the macros to be a form of documentation.
(eval-when (load eval compile)
(package-declare CL global 1000
()
(shadow error assoc member))
(pkg-goto 'CL))
;; this is error in common lisp.
(defmacro cl:error args
`(ferror nil ,@args))
;; ASSOC in CL is like ASSQ in ZetaLisp and MacLisp except that instead of testing
;; with EQ, it tests with EQL. In this code, we are stuck with EQ. Checking for
;; various types of tests would slow things down in this particular benchmark.
(defsubst cl:assoc (item a-list)
(assq item a-list))
;; In CL, MEMBER will default to EQ but allow the user to specify the test.
(defmacro cl:member (item lst ignore-test-keyword test)
`(mem ,test ,item ,lst))
;; Note that PUTF reverses the indicator and new value arguments in PUTPROP. Don't need to
;; repackage since there's no PUTF in ZetaLisp.
(defmacro putf (sym indicator new-value)
`(putprop ,sym ,new-value ,indicator))
;;; BOYER proper begins here
(defvar unify-subst)
(defvar temp-temp)
(defun add-lemma (term)
(cond ((and (not (atom term))
(eq (car term) 'equal)
(not (atom (cadr term))))
(putf (car (cadr term)) 'lemmas
(cons term (get (car (cadr term)) 'lemmas))))
(t (error "~%ADD-LEMMA didn't like TERM (~A)." term))))
(defun add-lemma-lst (lst)
(cond ((null lst)
t)
(t (add-lemma (car lst))
(add-lemma-lst (cdr lst)))))
(defun apply-subst (alist term)
(cond ((atom term)
(cond ((setq temp-temp (assoc term alist))
(cdr temp-temp))
(t term)))
(t (cons (car term)
(apply-subst-lst alist (cdr term))))))
(defun apply-subst-lst (alist lst)
(cond ((null lst)
nil)
(t (cons (apply-subst alist (car lst))
(apply-subst-lst alist (cdr lst))))))
(defun falsep (x lst)
(or (equal x '(f))
(member x lst :test 'equal)))
(defun one-way-unify (term1 term2)
(progn (setq unify-subst nil)
(one-way-unify1 term1 term2)))
(defun one-way-unify1 (term1 term2)
(cond ((atom term2)
(cond ((setq temp-temp (assq term2 unify-subst))
(equal term1 (cdr temp-temp)))
(t (setq unify-subst (cons (cons term2 term1)
unify-subst))
t)))
((atom term1)
nil)
((eq (car term1)
(car term2))
(one-way-unify1-lst (cdr term1)
(cdr term2)))
(t nil)))
(defun one-way-unify1-lst (lst1 lst2)
(cond ((null lst1)
t)
((one-way-unify1 (car lst1)
(car lst2))
(one-way-unify1-lst (cdr lst1)
(cdr lst2)))
(t nil)))
(defun rewrite (term)
(cond ((atom term)
term)
(t (rewrite-with-lemmas (cons (car term)
(rewrite-args (cdr term)))
(get (car term) 'lemmas)))))
(defun rewrite-args (lst)
(cond ((null lst)
nil)
(t (cons (rewrite (car lst))
(rewrite-args (cdr lst))))))
(defun rewrite-with-lemmas (term lst)
(cond ((null lst)
term)
((one-way-unify term (cadr (car lst)))
(rewrite (apply-subst unify-subst (caddr (car lst)))))
(t (rewrite-with-lemmas term (cdr lst)))))
(defun setup ()
(add-lemma-lst
'((equal (compile form)
(reverse (codegen (optimize form)
(nil))))
(equal (eqp x y)
(= (floor x) ; this was originally FIX
(floor x)))
(equal (> x y)
(< y x))
(equal (lesseqp x y)
(not (< y x)))
(equal (greatereqp x y)
(not (< x y)))
(equal (boolean x)
(or (equal x (t))
(equal x (f))))
(equal (iff x y)
(and (implies x y)
(implies y x)))
(equal (even1 x)
(if (zerop x)
(t)
(odd (1- x))))
(equal (countps- l pred)
(countps-loop l pred (zero)))
(equal (fact- i)
(fact-loop i 1))
(equal (reverse- x)
(reverse-loop x (nil)))
(equal (divides x y)
(zerop (remainder y x))) ; is this REM or REMAINDER in CL
(equal (assume-true var alist)
(cons (cons var (t))
alist))
(equal (assume-false var alist)
(cons (cons var (f))
alist))
(equal (tautology-checker x)
(tautologyp (normalize x)
(nil)))
(equal (falsify x)
(falsify1 (normalize x)
(nil)))
(equal (prime x)
(and (not (zerop x))
(not (equal x (1+ (zero))))
(prime1 x (1- x))))
(equal (and p q)
(if p (if q (t)
(f))
(f)))
(equal (or p q)
(if p (t)
(if q (t)
(f))
(f)))
(equal (not p)
(if p (f)
(t)))
(equal (implies p q)
(if p (if q (t)
(f))
(t)))
(equal (floor x)
(if (numberp x)
x
(zero)))
(equal (if (if a b c)
d e)
(if a (if b d e)
(if c d e)))
(equal (zerop x)
(or (equal x (zero))
(not (numberp x))))
(equal (+ (+ x y)
z)
(+ x (+ y z)))
(equal (equal (+ a b)
(zero))
(and (zerop a)
(zerop b)))
(equal (- x x)
(zero))
(equal (= (+ a b)
(+ a c))
(= (floor b)
(floor c)))
(equal (equal (zero)
(- x y))
(not (< y x)))
(equal (equal x (- x y))
(and (numberp x)
(or (equal x (zero))
(zerop y))))
(equal (meaning (plus-tree (append x y))
a)
(+ (meaning (plus-tree x)
a)
(meaning (plus-tree y)
a)))
(equal (meaning (plus-tree (plus-fringe x))
a)
(floor (meaning x a)))
(equal (append (append x y)
z)
(append x (append y z)))
(equal (reverse (append a b))
(append (reverse b)
(reverse a)))
(equal (* x (+ y z))
(+ (* x y)
(* x z)))
(equal (* (* x y)
z)
(* x (* y z)))
(equal (equal (* x y)
(zero))
(or (zerop x)
(zerop y)))
(equal (exec (append x y)
pds envrn)
(exec y (exec x pds envrn)
envrn))
(equal (mc-flatten x y)
(append (flatten x)
y))
(equal (member x (append a b) :test #'equal)
(or (member x a :test #'equal)
(member x b :test #'equal)))
(equal (member x (reverse y) :test #'equal)
(member x y :test #'equal))
(equal (length (reverse x))
(length x))
(equal (member a (intersect b c) :test #'equal)
(and (member a b :test #'equal)
(member a c :test #'equal)))
(equal (nth (zero)
i)
(zero))
(equal (exp i (+ j k))
(* (exp i j)
(exp i k)))
(equal (exp i (* j k))
(exp (exp i j)
k))
(equal (reverse-loop x y)
(append (reverse x)
y))
(equal (reverse-loop x (nil))
(reverse x))
(equal (count-list z (sort-lp x y))
(+ (count-list z x)
(count-list z y)))
(equal (equal (append a b)
(append a c))
(equal b c))
(equal (+ (remainder x y)
(* y (// x y))) ; couldn't beat slashification
(floor x))
(equal (power-eval (big-plus1 l i base)
base)
(+ (power-eval l base)
i))
(equal (power-eval (big-+ x y i base)
base)
(+ i (+ (power-eval x base)
(power-eval y base))))
(equal (remainder y 1)
(zero))
(equal (< (remainder x y)
y)
(not (zerop y)))
(equal (remainder x x)
(zero))
(equal (< (// i j)
i)
(and (not (zerop i))
(or (zerop j)
(not (equal j 1)))))
(equal (< (remainder x y)
x)
(and (not (zerop y))
(not (zerop x))
(not (< x y))))
(equal (power-eval (power-rep i base)
base)
(floor i))
(equal (power-eval (big-+ (power-rep i base)
(power-rep j base)
(zero)
base)
base)
(+ i j))
(equal (gcd x y)
(gcd y x))
(equal (nth (append a b)
i)
(append (nth a i)
(nth b (- i (length a)))))
(equal (- (+ x y)
x)
(floor y))
(equal (- (+ y x)
x)
(floor y))
(equal (- (+ x y)
(+ x z))
(- y z))
(equal (* x (- c w))
(- (* c x)
(* w x)))
(equal (remainder (* x z)
z)
(zero))
(equal (- (+ b (+ a c))
a)
(+ b c))
(equal (- (1+ (+ y z))
z)
(1+ y))
(equal (< (+ x y)
(+ x z))
(< y z))
(equal (< (* x z)
(* y z))
(and (not (zerop z))
(< x y)))
(equal (< y (+ x y))
(not (zerop x)))
(equal (gcd (* x z)
(* y z))
(* z (gcd x y)))
(equal (value (normalize x)
a)
(value x a))
(equal (equal (flatten x)
(cons y (nil)))
(and (nlistp x)
(equal x y)))
(equal (listp (gopher x))
(listp x))
(equal (samefringe x y)
(equal (flatten x)
(flatten y)))
(equal (equal (greatest-factor x y)
(zero))
(and (or (zerop y)
(equal y 1))
(equal x (zero))))
(equal (equal (greatest-factor x y)
1)
(equal x 1))
(equal (numberp (greatest-factor x y))
(not (and (or (zerop y)
(equal y 1))
(not (numberp x)))))
(equal (times-list (append x y))
(* (times-list x)
(times-list y)))
(equal (prime-list (append x y))
(and (prime-list x)
(prime-list y)))
(equal (equal z (* w z))
(and (numberp z)
(or (equal z (zero))
(equal w 1))))
(equal (greatereqpr x y)
(not (< x y)))
(equal (equal x (* x y))
(or (equal x (zero))
(and (numberp x)
(equal y 1))))
(equal (remainder (* y x)
y)
(zero))
(equal (equal (* a b)
1)
(and (not (equal a (zero)))
(not (equal b (zero)))
(numberp a)
(numberp b)
(equal (1- a)
(zero))
(equal (1- b)
(zero))))
(equal (< (length (delete x l))
(length l))
(member x l :test #'equal))
(equal (sort2 (delete x l))
(delete x (sort2 l)))
(equal (dsort x)
(sort2 x))
(equal (length (cons x1
(cons x2
(cons x3 (cons x4
(cons x5
(cons x6 x7)))))))
(+ 6 (length x7)))
(equal (- (1+ (1+ x))
2)
(floor x))
(equal (// (+ x (+ x y))
2)
(+ x (// y 2)))
(equal (sigma (zero)
i)
(// (* i (1+ i))
2))
(equal (+ x (1+ y))
(if (numberp y)
(1+ (+ x y))
(1+ x)))
(equal (equal (- x y)
(- z y))
(if (< x y)
(not (< y z))
(if (< z y)
(not (< y x))
(equal (floor x)
(floor z)))))
(equal (meaning (plus-tree (delete x y))
a)
(if (member x y :test #'equal)
(- (meaning (plus-tree y)
a)
(meaning x a))
(meaning (plus-tree y)
a)))
(equal (* x (1+ y))
(if (numberp y)
(+ x (* x y))
(floor x)))
(equal (nth (nil)
i)
(if (zerop i)
(nil)
(zero)))
(equal (last (append a b))
(if (listp b)
(last b)
(if (listp a)
(cons (car (last a))
b)
b)))
(equal (equal (< x y)
z)
(if (< x y)
(equal t z)
(equal f z)))
(equal (assignment x (append a b))
(if (assignedp x a)
(assignment x a)
(assignment x b)))
(equal (car (gopher x))
(if (listp x)
(car (flatten x))
(zero)))
(equal (flatten (cdr (gopher x)))
(if (listp x)
(cdr (flatten x))
(cons (zero)
(nil))))
(equal (// (* y x)
y)
(if (zerop y)
(zero)
(floor x)))
(equal (get j (set i val mem))
(if (eqp j i)
val
(get j mem))))))
(defun tautologyp (x true-lst false-lst)
(cond ((truep x true-lst)
t)
((falsep x false-lst)
nil)
((atom x)
nil)
((eq (car x) 'if)
(cond ((truep (cadr x)
true-lst)
(tautologyp (caddr x)
true-lst false-lst))
((falsep (cadr x)
false-lst)
(tautologyp (cadddr x)
true-lst false-lst))
(t (and (tautologyp (caddr x)
(cons (cadr x)
true-lst)
false-lst)
(tautologyp (cadddr x)
true-lst
(cons (cadr x)
false-lst))))))
(t nil)))
(defun tautp (x)
(tautologyp (rewrite x)
nil nil))
(defun test ()
(prog (ans term)
(setq term
(apply-subst
'((x f (+ (+ a b)
(+ c (zero))))
(y f (* (* a b)
(+ c d)))
(z f (reverse (append (append a b)
(nil))))
(u equal (+ a b)
(- x y))
(w < (remainder a b)
(member a (length b) :test #'equal)))
'(implies (and (implies x y)
(and (implies y z)
(and (implies z u)
(implies u w))))
(implies x w))))
(setq ans (tautp term))))
(defun trans-of-implies (n)
(list 'implies
(trans-of-implies1 n)
(list 'implies 0 n)))
(defun trans-of-implies1 (n)
(cond ((equal n 1)
(list 'implies 0 1))
(t (list 'and
(list 'implies (1- n) n)
(trans-of-implies1 (1- n))))))
(defun truep (x lst)
(or (equal x '(t))
(member x lst :test #'equal)))
(setup)
;;; end of bench
(user:deftimer boyer (cl:test)) ; ZetaLisp timer, not Common Lisp.
;;; BROWSE -- Benchmark to create and browse through an AI-like data base of units.
;;; Common Lisp version.
;;; n is # of symbols
;;; m is maximum amount of stuff on the plist
;;; npats is the number of basic patterns on the unit
;;; ipats is the instantiated copies of the patterns
;;; Common Lisp macros.
(eval-when (load eval compile)
(package-declare CL global 1000
()
(shadow assoc))
(pkg-goto 'cl))
;; Purely cosmetic.
(defsubst cl:assoc (item alist ignore-keyword ignore-test)
(global:assoc item alist))
;; Note that PUTF reverses the indicator and new value arguments.
(defmacro putf (sym indicator new-value)
`(putprop ,sym ,new-value ,indicator))
;; This was in the original code. MOD is equivalent to REMAINDER in this
;; routine, because it only gets positive arguments.
(defmacro mod (x n) `(remainder ,x ,n))
;;; the actual BROWSE benchmark begins here
(defvar rand 21.)
;; This returns the char value (fixnum) of the 1st char of a symbol name
(defmacro char1 (x) `(aref (string ,x) 0.))
(defun init (n m npats ipats)
(let ((ipats (subst () () ipats)))
(do ((p ipats (cdr p)))
((null (cdr p)) (rplacd p ipats)))
(do ((n n (1- n))
(i m (cond ((= i 0) m)
nn (t (1- i)))) ;
(name (intern (gensym)) (intern (gensym)))
(a ()))
((= n 0) annn)
(push name a)
(do ((i i (1- i)))
((= i 0))
(putf name (gensym) nil))
(putf name 'pattern
(do ((i npats (1- i))
(ipats ipats (cdr ipats))
(a ()))
((= i 0) a)
(push (car ipats) a)))
(do ((j (- m i) (1- j)))
((= j 0))
(putf name (gensym) nil)))))
(defmacro seed ()
(setq rand 21.))
(defmacro browse-random ()
(setq rand (mod (* rand 17.) 251.)))
(defun randomize (l)
(do ((a ()))
((null l) a)
(let ((n (mod (browse-random) (length l))))
(cond ((= n 0)
(push (car l) a)
(setq l (cdr l)))
(t
(do ((n n (1- n))
(x l (cdr x)))
((= n 1)
(push (cadr x) a)
(rplacd x (cddr x)))))))))
(defun match (pat dat alist)
(cond ((null pat)
(null dat))
((null dat) ())
((or (eq (car pat) '?)
(eq (car pat)
(car dat)))
(match (cdr pat) (cdr dat) alist))
((eq (car pat) '*)
(or (match (cdr pat) dat alist)
(match (cdr pat) (cdr dat) alist)
(match pat (cdr dat) alist)))
(t (cond ((atom (car pat))
(cond ((eq (char1 (car pat)) #\?)
(let ((val (assoc (car pat) alist :test #'equal)))
(cond (val (match (cons (cdr val)
(cdr pat))
dat alist))
(t (match (cdr pat)
(cdr dat)
(cons (cons (car pat)
(car dat))
alist))))))
((eq (char1 (car pat)) #\*)
(let ((val (assoc (car pat) alist :test #'equal)))
(cond (val (match (append (cdr val)
(cdr pat))
dat alist))
(t
(do ((l () (nconc l (cons (car d) nil)))
(e (cons () dat) (cdr e))
(d dat (cdr d)))
((null e) ())
(cond ((match (cdr pat) d
(cons (cons (car pat) l)
alist))
(return t))))))))))
(t (and
(not (atom (car dat)))
(match (car pat)
(car dat) alist)
(match (cdr pat)
(cdr dat) alist)))))))
(defun browse ()
(seed)
(investigate (randomize
(init 100. 10. 4. '((a a a b b b b a a a a a b b a a a)
(a a b b b b a a
(a a)(b b))
(a a a b (b a) b a b a))))
'((*a ?b *b ?b a *a a *b *a)
(*a *b *b *a (*a) (*b))
(? ? * (b a) * ? ?))))
(defun investigate (units pats)
(do ((units units (cdr units)))
((null units))
(do ((pats pats (cdr pats)))
((null pats))
(do ((p (get 'pattern (car units))
(cdr p)))
((null p))
(match (car pats) (car p) ())))))
;;; end of bench
(user:deftimer browse (cl:browse)) ; ZetaLisp timer
;;; CTAK -- A version of the TAKeuchi function that tests the CATCH/THROW facility.
(defun ctak (x y z)
(*catch 'ctak (ctak-aux x y z)))
(defun ctak-aux (x y z)
(cond ((not (< y x)) ;x≤y
(*throw 'ctak z))
(t (ctak-aux
(*catch 'ctak
(ctak-aux (1- x)
y
z))
(*catch 'ctak
(ctak-aux (1- y)
z
x))
(*catch 'ctak
(ctak-aux (1- z)
x
y))))))
(deftimer ctak (ctak 18. 12. 6.)) ; ZetaLisp timer
;;; DDERIV -- The Common Lisp version of a symbolic derivative benchmark, written
;;; by Vaughn Pratt.
;;; This benchmark is a variant of the simple symbolic derivative program
;;; (DERIV). The main change is that it is "table-driven". Instead of using a
;;; large COND that branches on the CAR of the expression, this program finds
;;; the code that will take the derivative on the property list of the atom in
;;; the CAR position. So, when the expression is (+ . <rest>), the code
;;; stored under the atom '+ with indicator DDERIV will take <rest> and
;;; return the derivative for '+.
;;; I'm not sure that the ":property" keyword is Common Lisp -- PW
(defun dderiv-aux (a)
(list '// (dderiv a) a))
(defun (:property + dderiv) (a)
(cons '+ (mapcar 'dderiv a)))
(defun (:property - dderiv) (a)
(cons '- (mapcar 'dderiv a)))
(defun (:property * dderiv) (a)
(list '* (cons '* a)
(cons '+ (mapcar 'dderiv-aux a))))
(defun (:property // dderiv) (a)
(list '-
(list '//
(dderiv (car a))
(cadr a))
(list '//
(car a)
(list '*
(cadr a)
(cadr a)
(dderiv (cadr a))))))
(defun dderiv (a)
(cond
((atom a)
(cond ((eq a 'x) 1) (t 0)))
(t (let ((dderiv (get (car a) 'dderiv)))
(cond (dderiv (funcall dderiv (cdr a)))
(t 'error))))))
(defun run ()
(declare (fixnum i))
(do ((i 0 (1+ i)))
((= i 1000.))
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))))
(deftimer dderiv (run)) ; ZetaLisp timer
;;; DESTRU -- Destructive operation benchmark
(defun destructive (n m)
(let ((l (do ((i 10. (1- i))
(a () (push () a)))
((= i 0) a))))
(do ((i n (1- i)))
((= i 0))
(cond ((null (car l))
(do ((l l (cdr l)))
((null l))
(or (car l)
(rplaca l (cons nil nil)))
(nconc (car l)
(do ((j m (1- j))
(a () (push () a)))
((= j 0) a)))))
(t
(do ((l1 l (cdr l1))
(l2 (cdr l) (cdr l2)))
((null l2))
(rplacd (do ((j (// (length (car l2)) 2) (1- j))
(a (car l2) (cdr a)))
((= j 0) a)
(rplaca a i))
(let ((n (// (length (car l1)) 2)))
(cond ((= n 0) (rplaca l1 ())
(car l1))
(t
(do ((j n (1- j))
(a (car l1) (cdr a)))
((= j 1)
(prog1 (cdr a)
(rplacd a ())))
(rplaca a i))))))))))))
(deftimer destru (destructive 600. 50.)) ; ZetaLisp timer
;;; DIV2 -- Benchmark which divides by 2 using lists of n ()'s.
;;; Contains a recursive as well as an iterative test.
(defun create-n (n)
(do ((n n (1- n))
(a () (push () a)))
((= n 0) a)))
(defvar l (create-n 200.))
(defun iterative-div2 (l)
(do ((l l (cddr l))
(a () (push (car l) a)))
((null l) a)))
(defun recursive-div2 (l)
(cond ((null l) ())
(t (cons (car l) (recursive-div2 (cddr l))))))
(defun iterative-test (l)
(do ((i 300. (1- i)))
((= i 0))
(iterative-div2 l)
(iterative-div2 l)
(iterative-div2 l)
(iterative-div2 l)))
(defun recursive-test (l)
(do ((i 300. (1- i)))
((= i 0))
(recursive-div2 l)
(recursive-div2 l)
(recursive-div2 l)
(recursive-div2 l)))
(defmacro div2-bench () ; macro that calls ZetaLisp timer
`(progn
(deftimer div2 (iterative-test l))
(timit "iterative test.")
(deftimer div2 (recursive-test l))
(timit "recursive test.")))
;;; FFT -- This is an FFT benchmark written by Harry Barrow.
;;; It tests a variety of floating point operations, including array references.
;; Common Lisp Package for redefining system fns.
(eval-when (load eval compile)
(package-declare CL global 1000
()
(shadow make-array))
(pkg-goto 'CL))
;; Cosmetic patch to MAKE-ARRAY as used in this bench. The White Pages say that
;; the type of the initial-element must match the array type. Ergo(???), you have to
;; declare the array type.
(defsubst cl:make-array (dimensions &optional ignore-type-keyword ignore-type
init-keyword initial-element)
(prog ((arr (global:make-array dimensions)))
(cond (init-keyword (fillarray arr (list initial-element))))
(return arr)))
;;; FFT bench begins here
(defvar re (make-array 1025. ':type ':float ':initial-element 0.0))
(defvar im (make-array 1025. ':type ':float ':initial-element 0.0))
(defun fft ;fast fourier transform
(areal aimag) ;areal = real part
(prog ;aimag = imaginary part
(ar ai pi i j k m n le le1 ip nv2 nm1 ur ui wr wi tr ti)
(setq ar areal ;initialize
ai aimag
pi 3.141592653589793
n (array-dimension-n 1 ar)
n (1- n)
nv2 (// n 2)
nm1 (1- n)
m 0 ;compute m = log(n)
i 1)
loop-1
(cond ((< i n)
(setq m (1+ m)
i (+ i i))
(go loop-1)))
(cond ((not (equal n (↑ 2 m)))
(princ "error ... array size not a power of two.")
(read)
(return (terpri))))
(setq j 1 ;interchange elements
i 1) ;in bit-reversed order
loop-3
(cond ((< i j)
(setq tr (aref ar j)
ti (aref ai j))
(setf (aref ar j) (aref ar i))
(setf (aref ai j) (aref ai i))
(setf (aref ar i) tr)
(setf (aref ai i) ti)))
(setq k nv2)
loop-6
(cond ((< k j)
(setq j (- j k)
k (// k 2))
(go loop-6)))
(setq j (+ j k)
i (1+ i))
(cond ((< i n)
(go loop-3)))
(do l 1 (1+ l) (> l m) ;loop thru stages
(setq le (↑ 2 l)
le1 (// le 2)
ur 1.0
ui 0.
wr (cos (// pi (float le1)))
wi (sin (// pi (float le1))))
(do j 1 (1+ j) (> j le1) ;loop thru butterflies
(do i j (+ i le) (> i n) ;do a butterfly
(setq ip (+ i le1)
tr (- (* (aref ar ip) ur)
(* (aref ai ip) ui))
ti (+ (* (aref ar ip) ui)
(* (aref ai ip) ur)))
(setf (aref ar ip) (- (aref ar i) tr))
(setf (aref ai ip) (- (aref ai i) ti))
(setf (aref ar i) (+ (aref ar i) tr))
(setf (aref ai i) (+ (aref ai i) ti))))
(setq tr (- (* ur wr) (* ui wi))
ti (+ (* ur wi) (* ui wr))
ur tr
ui ti))
(return t)))
;;; end of bench
(user:deftimer fft ; ZetaLisp timer which does 10 calls on FFT
(do ((ntimes 0 (1+ ntimes)))
((= ntimes 10.))
(cl:fft re im)))
;;; FPRINT -- Benchmark to print to a file.
;;; The CL package is just to shadow OPEN
(eval-when (load eval compile)
(package-declare cl global 1000
()
(shadow open))
(pkg-goto 'cl))
(defmacro cl:open (path-name ignore-keyword ignore-direction)
`(global:open ,path-name ':out))
(defmacro probe-file (file-name)
`(probef ,file-name))
(defmacro delete-file (file-name)
`(deletef ,file-name))
;;; FPRINT begins here
(defvar test-atoms '(abcdef12 cdefgh23 efghij34 ghijkl45 ijklmn56 klmnop67
mnopqr78 opqrst89 qrstuv90 stuvwx01 uvwxyz12
wxyzab23 xyzabc34 123456ab 234567bc 345678cd
456789de 567890ef 678901fg 789012gh 890123hi))
(defun init-aux (m n atoms)
(cond ((= m 0) (pop atoms))
(t (do ((i n (- i 2))
(a ()))
((< i 1) a)
(push (pop atoms) a)
(push (init-aux (1- m) n atoms) a)))))
(defun init (m n atoms)
(let ((atoms (subst () () atoms)))
(do ((a atoms (cdr a)))
((null (cdr a)) (rplacd a atoms)))
(init-aux m n atoms)))
(defvar test-pattern (init 6. 6. test-atoms))
(defun fprint ()
(cond ((probe-file "fprint.tst")
(delete-file "fprint.tst")))
(let ((stream (open "fprint.tst" :direction ':output))) ;defaults to STRING-CHAR
(print test-pattern stream)
(close stream)))
(cond ((probe-file "fprint.tst"))
(t
(let ((stream (open "fprint.tst" :direction ':output)))
(print test-pattern stream)
(close stream))))
;;; end of bench
(user:deftimer fprint (cl:fprint)) ; ZetaLisp timer
;;; FREAD -- Benchmark to read from a file.
;;; Pronounced "FRED". Requires the existance of FPRINT.TST which is created
;;; by FPRINT.
;;; The CL package is just to shadow OPEN
(eval-when (load eval compile)
(package-declare cl global 1000
()
(shadow open))
(pkg-goto 'cl))
(defmacro cl:open (path-name ignore-keyword direction)
`(cond ((equal ,direction ':input)
(global:open ,path-name ':in))
(t (global:open ,path-name ':out))))
;;; FREAD begins here.
(defun fread ()
(let ((stream (open "fprint.tst" :direction ':input)))
(read stream)
(close stream)))
(cond ((probe-file "fprint.tst"))
(t (format t "~%Define FPRINT.TST by running the FPRINT benchmark!")
(let ((stream (open "fprint.tst" :direction ':output)))
(print test-pattern stream)
(close stream))))
;;; end of bench
(user:deftimer fread (cl:fread)) ; ZetaLisp timer
;;; FRPOLY -- Benchmark from Berkeley based on polynomial arithmetic.
;;; Originally writen in Franz Lisp by Richard Fateman.
;;; PDIFFER1 is mentioned but not defined; is not called for these tests, however. [???]
;; for Common Lisp
(defmacro putf (sym indicator new-value)
`(putprop ,sym ,new-value ,indicator))
;;; FRPOLY bench begins here
(defconst pzero 0)
(defvar ans)
(defvar coef)
(defvar f)
(defvar inc)
(defvar i)
(defvar qq)
(defvar ss)
(defvar v)
(defvar *x*)
(defvar *alpha*)
(defvar *a*)
(defvar *b*)
(defvar *chk)
(defvar *l)
(defvar *p)
(defvar q*)
(defvar u*)
(defvar *var)
(defvar *y*)
(defvar r)
(defvar r2)
(defvar r3)
(defvar start)
(defvar res1)
(defvar res2)
(defvar res3)
(defmacro pointergp (x y) `(> (get ,x 'order)(get ,y 'order)))
(defmacro pcoefp (e) `(atom ,e))
(defmacro pzerop (x) ; True for 0 or 0.0.
`(cond ; This originally used SIGNP instead of
((numberp ,x) (zerop ,x)) ; ZEROP which returns an error when its arg
(t nil))) ; is not a number
(defmacro cplus (x y) `(+ ,x ,y))
(defmacro ctimes (x y) `(* ,x ,y))
(defun pcoefadd (e c x) (cond ((pzerop c) x)
(t (cons e (cons c x)))))
(defun pcplus (c p) (cond ((pcoefp p) (cplus p c))
(t (psimp (car p) (pcplus1 c (cdr p))))))
(defun pcplus1 (c x)
(cond ((null x)
(cond ((pzerop c) nil) (t (cons 0 (cons c nil)))))
((pzerop (car x)) (pcoefadd 0 (pplus c (cadr x)) nil))
(t (cons (car x) (cons (cadr x) (pcplus1 c (cddr x)))))))
(defun pctimes (c p)
(cond ((pcoefp p) (ctimes c p))
(t (psimp (car p) (pctimes1 c (cdr p))))))
(defun pctimes1 (c x)
(cond ((null x) nil)
(t (pcoefadd (car x)
(ptimes c (cadr x))
(pctimes1 c (cddr x))))))
(defun pplus (x y)
(cond ((pcoefp x) (pcplus x y))
((pcoefp y) (pcplus y x))
((eq (car x) (car y))
(psimp (car x) (pplus1 (cdr y) (cdr x))))
((pointergp (car x) (car y))
(psimp (car x) (pcplus1 y (cdr x))))
(t (psimp (car y) (pcplus1 x (cdr y))))))
(defun pplus1 (x y)
(cond ((null x) y)
((null y) x)
((= (car x) (car y))
(pcoefadd (car x)
(pplus (cadr x) (cadr y))
(pplus1 (cddr x) (cddr y))))
((> (car x) (car y))
(cons (car x) (cons (cadr x) (pplus1 (cddr x) y))))
(t (cons (car y) (cons (cadr y) (pplus1 x (cddr y)))))))
(defun psimp (var x)
(cond ((null x) 0)
((atom x) x)
((zerop (car x)) (cadr x))
(t (cons var x))))
(defun ptimes (x y)
(cond ((or (pzerop x) (pzerop y)) (pzero))
((pcoefp x) (pctimes x y))
((pcoefp y) (pctimes y x))
((eq (car x) (car y))
(psimp (car x) (ptimes1 (cdr x) (cdr y))))
((pointergp (car x) (car y))
(psimp (car x) (pctimes1 y (cdr x))))
(t (psimp (car y) (pctimes1 x (cdr y))))))
(defun ptimes1 (*x* y)
(prog (u* v)
(setq v (setq u* (ptimes2 y)))
a (setq *x* (cddr *x*))
(cond ((null *x*) (return u*)))
(ptimes3 y)
(go a)))
(defun ptimes2 (y)
(cond ((null y) nil)
(t (pcoefadd (+ (car *x*) (car y))
(ptimes (cadr *x*) (cadr y))
(ptimes2 (cddr y))))))
(defun ptimes3 (y)
(prog (e u c)
a1 (cond ((null y)
(return nil)))
(setq e (+ (car *x*) (car y)))
(setq c (ptimes (cadr y) (cadr *x*) ))
(cond ((pzerop c) (setq y (cddr y))
(go a1))
((or (null v) (> e (car v)))
(setq u* (setq v (pplus1 u* (list e c))))
(setq y (cddr y)) (go a1))
((= e (car v))
(setq c (pplus c (cadr v)))
(cond ((pzerop c) ; never true, evidently
(setq u* (setq v (pdiffer1 u* (list (car v) (cadr v))))))
(t (rplaca (cdr v) c)))
(setq y (cddr y))
(go a1)))
a (cond ((and (cddr v) (> (caddr v) e))
(setq v (cddr v)) (go a)))
(setq u (cdr v))
b (cond ((or (null (cdr u)) (< (cadr u) e))
(rplacd u (cons e (cons c (cdr u)))) (go e)))
(cond ((pzerop (setq c (pplus (caddr u) c))) (rplacd u (cdddr u)) (go d))
(t (rplaca (cddr u) c)))
e (setq u (cddr u))
d (setq y (cddr y))
(cond ((null y) (return nil)))
(setq e (+ (car *x*) (car y)))
(setq c (ptimes (cadr y) (cadr *x*)))
c (cond ((and (cdr u) (> (cadr u) e)) (setq u (cddr u)) (go c)))
(go b)))
(defun pexptsq (p n)
(do ((n (// n 2) (// n 2))
(s (cond ((oddp n) p) (t 1))))
((zerop n) s)
(setq p (ptimes p p))
(and (oddp n) (setq s (ptimes s p))) ))
(defun setup ()
(putf 'x 'order 1)
(putf 'y 'order 2)
(putf 'z 'order 3)
(setq r (pplus '(x 1 1 0 1) (pplus '(y 1 1) '(z 1 1)))) ; r= x+y+z+1
(setq r2 (ptimes r 100000)) ;r2 = 100000*r
(setq r3 (ptimes r 1.0))) ; r3 = r with floating point coefficients
(eval-when (eval load compile)
(setup))
;;; end of bench
(defmacro bench (n) ; calls ZetaLisp timing fn.
`(progn
(print 'test-1)
(deftimer frpoly (pexptsq r ,n))
(timit (format nil "Power of Polynomial = ~D. r = x+y+z+1" ,n))
(print 'test-2)
(deftimer frpoly (pexptsq r2 ,n))
(timit (format nil "Power of Polynomial = ~D. r2 = 100000*r" ,n))
(print 'test-3)
(deftimer frpoly (pexptsq r3 ,n))
(timit
(format nil "Power of Polynomial = ~D. r3 = r with floating point coefficients" ,n))))
;;; PUZZLE --
;; Common Lisp Package for redefining system fns.
(eval-when (load eval compile)
(package-declare CL global 1000
()
(shadow make-array))
(pkg-goto 'CL))
;; Cosmetic patch to MAKE-ARRAY as used in this bench. The White Pages say that
;; the type of the initial-element must match the array type. Ergo(???), you have to
;; declare the array type.
(defsubst cl:make-array (dimensions &optional ignore-type-keyword ignore-type
init-keyword initial-element)
(prog ((arr (global:make-array dimensions)))
(cond (init-keyword (fillarray arr (list initial-element))))
(return arr)))
;;; PUZZLE bench begins here
(eval-when (compile load eval)
(defconst size 511.)
(defconst classmax 3.)
(defconst typemax 12.)
(defconst true t)
(defconst false nil))
(defvar iii 0)
(defvar kount 0)
(defvar d 8.)
(defvar piececount (make-array (1+ classmax) ':type ':fixnum ':initial-element 0))
(defvar class (make-array (1+ typemax) ':type ':fixnum ':initial-element 0))
(defvar piecemax (make-array (1+ typemax) ':type ':fixnum ':initial-element 0))
(defvar puzzle (make-array (1+ size)))
(defvar p (make-array (list (1+ typemax) (1+ size))))
(defun fit (i j)
(let ((end (aref piecemax i)))
(do ((k 0 (1+ k)))
((> k end) #.true)
(cond ((aref p i k)
(cond ((aref puzzle (+ j k))
(return #.false))))))))
(defun place (i j)
(let ((end (aref piecemax i)))
(do ((k 0 (1+ k)))
((> k end))
(cond ((aref p i k)
(setf (aref puzzle (+ j k)) #.true))))
(setf (aref piececount (aref class i)) (- (aref piececount (aref class i)) 1))
(do ((k j (1+ k)))
((> k size)
(format t "~%Puzzle filled.")
0)
(cond ((not (aref puzzle k))
(return k))))))
(defun puzzle-remove (i j)
(let ((end (aref piecemax i)))
(do ((k 0 (1+ k)))
((> k end))
(cond ((aref p i k) (setf (aref puzzle (+ j k)) #.false))))
(setf (aref piececount (aref class i)) (1+ (aref piececount (aref class i))))))
(defun trial (j)
(let ((k 0))
(do ((i 0 (1+ i)))
((> i typemax) (setq kount (1+ kount)) #.false)
(cond ((not (= (aref piececount (aref class i)) 0))
(cond ((fit i j)
(setq k (place i j))
(cond ((or (trial k)
(= k 0))
(format t "~%Piece ~4D at ~4D." (1+ i) (1+ k))
(setq kount (+ kount 1))
(return #.true))
(t (puzzle-remove i j))))))))))
(defun definepiece (iclass ii jj kk)
(let ((index 0))
(do ((i 0 (1+ i)))
((> i ii))
(do ((j 0 (1+ j)))
((> j jj))
(do ((k 0 (1+ k)))
((> k kk))
(setq index (+ i (* d (+ j (* d k)))))
(setf (aref p iii index) #.true))))
(setf (aref class iii) iclass)
(setf (aref piecemax iii) index)
(cond ((not (= iii typemax))
(setq iii (1+ iii))))))
(defun start ()
(do ((m 0 (1+ m)))
((> m size))
(setf (aref puzzle m) #.true))
(do ((i 1 (1+ i)))
((> i 5))
(do ((j 1 (1+ j)))
((> j 5))
(do ((k 1 (1+ k)))
((> k 5))
(setf (aref puzzle (+ i (* d (+ j (* d k))))) #.false))))
(do ((i 0 (1+ i)))
((> i typemax))
(do ((m 0 (1+ m)))
((> m size))
(setf (aref p i m) #.false)))
(setq iii 0)
(definePiece 0 3 1 0)
(definePiece 0 1 0 3)
(definePiece 0 0 3 1)
(definePiece 0 1 3 0)
(definePiece 0 3 0 1)
(definePiece 0 0 1 3)
(definePiece 1 2 0 0)
(definepiece 1 0 2 0)
(definePiece 1 0 0 2)
(definePiece 2 1 1 0)
(definePiece 2 1 0 1)
(definePiece 2 0 1 1)
(definePiece 3 1 1 1)
(setf (aref pieceCount 0) 13.)
(setf (aref pieceCount 1) 3)
(setf (aref pieceCount 2) 1)
(setf (aref pieceCount 3) 1)
(let ((m (1+ (* d (1+ d))))
(n 0)(kount 0))
(cond ((fit 0 m) (setq n (place 0 m)))
(t (format t "~%Error.")))
(cond ((trial n)
(format t "~%Success in ~4D trials." kount))
(t (format t "~%Failure.")))))
;;; end of bench
(user:deftimer puzzle (cl:start)) ; ZetaLisp timing fn.
;;; STAK -- The TAKeuchi function with special variables instead of parameter passing.
(defvar x)
(defvar y)
(defvar z)
(defun stak (x y z)
(stak-aux))
(defun stak-aux ()
(cond ((not (< y x)) ;x≤y
z)
(t (let ((x (let ((x (1- x))
(y y)
(z z))
(stak-aux)))
(y (let ((x (1- y))
(y z)
(z x))
(stak-aux)))
(z (let ((x (1- z))
(y x)
(z y))
(stak-aux))))
(stak-aux)))))
(deftimer stak (stak 18. 12. 6.)) ; ZetaLisp timer
;;; TAK -- A vanilla version of the TAKeuchi function and one with tail recursion
;;; removed.
(defun tak (x y z)
(cond ((not (< y x)) ;x≤y
z)
(t (tak (tak (1- x) y z)
(tak (1- y) z x)
(tak (1- z) x y)))))
(defun trtak (x y z)
(prog ()
tak
(cond ((not (< y x))
(return z))
(t (let ((a (tak (1- x) y z))
(b (tak (1- y) z x)))
(setq z (tak (1- z) x y))
(setq x a y b)(go tak))))))
(defmacro tak-bench () ; calls ZetaLisp timer
`(progn
(print "TAK")
(deftimer tak (tak 18. 12. 6.))
(timit "Takeuchi function.")
(print "TRTAK")
(deftimer trtak (trtak 18. 12. 6.))
(timit "Takeuchi function with tail recursion removed.")))
;;; TAKL -- The TAKeuchi function using lists as counters.
(defvar 18l (listn 18.))
(defvar 12l (listn 12.))
(defvar 6l (listn 6.))
(defun listn (n)
(cond
((= 0 n)
nil)
(t (cons n (listn (1- n))))))
(defun mas (x y z)
(cond
((not (shorterp y x))
z)
(t (mas (mas (cdr x)
y z)
(mas (cdr y)
z x)
(mas (cdr z)
x y)))))
(defun shorterp (x y)
(and y (or (null x)
(shorterp (cdr x)
(cdr y)))))
(deftimer TAKL (mas 18l 12l 6l)) ; ZetaLisp timer
;;; TAKR -- 100 function (count `em) version of TAK that tries to defeat cache
;;; memory effects. Distribution of calls is not completely flat.
(deftimer takr (tak0 18. 12. 6.)) ; ZetaLisp timer call
(defun tak0 (x y z)
(cond ((not (< y x)) z)
(t (tak1 (tak37 (1- x) y z)
(tak11 (1- y) z x)
(tak17 (1- z) x y)))))
(defun tak1 (x y z)
(cond ((not (< y x)) z)
(t (tak2 (tak74 (1- x) y z)
(tak22 (1- y) z x)
(tak34 (1- z) x y)))))
(defun tak2 (x y z)
(cond ((not (< y x)) z)
(t (tak3 (tak11 (1- x) y z)
(tak33 (1- y) z x)
(tak51 (1- z) x y)))))
(defun tak3 (x y z)
(cond ((not (< y x)) z)
(t (tak4 (tak48 (1- x) y z)
(tak44 (1- y) z x)
(tak68 (1- z) x y)))))
(defun tak4 (x y z)
(cond ((not (< y x)) z)
(t (tak5 (tak85 (1- x) y z)
(tak55 (1- y) z x)
(tak85 (1- z) x y)))))
(defun tak5 (x y z)
(cond ((not (< y x)) z)
(t (tak6 (tak22 (1- x) y z)
(tak66 (1- y) z x)
(tak2 (1- z) x y)))))
(defun tak6 (x y z)
(cond ((not (< y x)) z)
(t (tak7 (tak59 (1- x) y z)
(tak77 (1- y) z x)
(tak19 (1- z) x y)))))
(defun tak7 (x y z)
(cond ((not (< y x)) z)
(t (tak8 (tak96 (1- x) y z)
(tak88 (1- y) z x)
(tak36 (1- z) x y)))))
(defun tak8 (x y z)
(cond ((not (< y x)) z)
(t (tak9 (tak33 (1- x) y z)
(tak99 (1- y) z x)
(tak53 (1- z) x y)))))
(defun tak9 (x y z)
(cond ((not (< y x)) z)
(t (tak10 (tak70 (1- x) y z)
(tak10 (1- y) z x)
(tak70 (1- z) x y)))))
(defun tak10 (x y z)
(cond ((not (< y x)) z)
(t (tak11 (tak7 (1- x) y z)
(tak21 (1- y) z x)
(tak87 (1- z) x y)))))
(defun tak11 (x y z)
(cond ((not (< y x)) z)
(t (tak12 (tak44 (1- x) y z)
(tak32 (1- y) z x)
(tak4 (1- z) x y)))))
(defun tak12 (x y z)
(cond ((not (< y x)) z)
(t (tak13 (tak81 (1- x) y z)
(tak43 (1- y) z x)
(tak21 (1- z) x y)))))
(defun tak13 (x y z)
(cond ((not (< y x)) z)
(t (tak14 (tak18 (1- x) y z)
(tak54 (1- y) z x)
(tak38 (1- z) x y)))))
(defun tak14 (x y z)
(cond ((not (< y x)) z)
(t (tak15 (tak55 (1- x) y z)
(tak65 (1- y) z x)
(tak55 (1- z) x y)))))
(defun tak15 (x y z)
(cond ((not (< y x)) z)
(t (tak16 (tak92 (1- x) y z)
(tak76 (1- y) z x)
(tak72 (1- z) x y)))))
(defun tak16 (x y z)
(cond ((not (< y x)) z)
(t (tak17 (tak29 (1- x) y z)
(tak87 (1- y) z x)
(tak89 (1- z) x y)))))
(defun tak17 (x y z)
(cond ((not (< y x)) z)
(t (tak18 (tak66 (1- x) y z)
(tak98 (1- y) z x)
(tak6 (1- z) x y)))))
(defun tak18 (x y z)
(cond ((not (< y x)) z)
(t (tak19 (tak3 (1- x) y z)
(tak9 (1- y) z x)
(tak23 (1- z) x y)))))
(defun tak19 (x y z)
(cond ((not (< y x)) z)
(t (tak20 (tak40 (1- x) y z)
(tak20 (1- y) z x)
(tak40 (1- z) x y)))))
(defun tak20 (x y z)
(cond ((not (< y x)) z)
(t (tak21 (tak77 (1- x) y z)
(tak31 (1- y) z x)
(tak57 (1- z) x y)))))
(defun tak21 (x y z)
(cond ((not (< y x)) z)
(t (tak22 (tak14 (1- x) y z)
(tak42 (1- y) z x)
(tak74 (1- z) x y)))))
(defun tak22 (x y z)
(cond ((not (< y x)) z)
(t (tak23 (tak51 (1- x) y z)
(tak53 (1- y) z x)
(tak91 (1- z) x y)))))
(defun tak23 (x y z)
(cond ((not (< y x)) z)
(t (tak24 (tak88 (1- x) y z)
(tak64 (1- y) z x)
(tak8 (1- z) x y)))))
(defun tak24 (x y z)
(cond ((not (< y x)) z)
(t (tak25 (tak25 (1- x) y z)
(tak75 (1- y) z x)
(tak25 (1- z) x y)))))
(defun tak25 (x y z)
(cond ((not (< y x)) z)
(t (tak26 (tak62 (1- x) y z)
(tak86 (1- y) z x)
(tak42 (1- z) x y)))))
(defun tak26 (x y z)
(cond ((not (< y x)) z)
(t (tak27 (tak99 (1- x) y z)
(tak97 (1- y) z x)
(tak59 (1- z) x y)))))
(defun tak27 (x y z)
(cond ((not (< y x)) z)
(t (tak28 (tak36 (1- x) y z)
(tak8 (1- y) z x)
(tak76 (1- z) x y)))))
(defun tak28 (x y z)
(cond ((not (< y x)) z)
(t (tak29 (tak73 (1- x) y z)
(tak19 (1- y) z x)
(tak93 (1- z) x y)))))
(defun tak29 (x y z)
(cond ((not (< y x)) z)
(t (tak30 (tak10 (1- x) y z)
(tak30 (1- y) z x)
(tak10 (1- z) x y)))))
(defun tak30 (x y z)
(cond ((not (< y x)) z)
(t (tak31 (tak47 (1- x) y z)
(tak41 (1- y) z x)
(tak27 (1- z) x y)))))
(defun tak31 (x y z)
(cond ((not (< y x)) z)
(t (tak32 (tak84 (1- x) y z)
(tak52 (1- y) z x)
(tak44 (1- z) x y)))))
(defun tak32 (x y z)
(cond ((not (< y x)) z)
(t (tak33 (tak21 (1- x) y z)
(tak63 (1- y) z x)
(tak61 (1- z) x y)))))
(defun tak33 (x y z)
(cond ((not (< y x)) z)
(t (tak34 (tak58 (1- x) y z)
(tak74 (1- y) z x)
(tak78 (1- z) x y)))))
(defun tak34 (x y z)
(cond ((not (< y x)) z)
(t (tak35 (tak95 (1- x) y z)
(tak85 (1- y) z x)
(tak95 (1- z) x y)))))
(defun tak35 (x y z)
(cond ((not (< y x)) z)
(t (tak36 (tak32 (1- x) y z)
(tak96 (1- y) z x)
(tak12 (1- z) x y)))))
(defun tak36 (x y z)
(cond ((not (< y x)) z)
(t (tak37 (tak69 (1- x) y z)
(tak7 (1- y) z x)
(tak29 (1- z) x y)))))
(defun tak37 (x y z)
(cond ((not (< y x)) z)
(t (tak38 (tak6 (1- x) y z)
(tak18 (1- y) z x)
(tak46 (1- z) x y)))))
(defun tak38 (x y z)
(cond ((not (< y x)) z)
(t (tak39 (tak43 (1- x) y z)
(tak29 (1- y) z x)
(tak63 (1- z) x y)))))
(defun tak39 (x y z)
(cond ((not (< y x)) z)
(t (tak40 (tak80 (1- x) y z)
(tak40 (1- y) z x)
(tak80 (1- z) x y)))))
(defun tak40 (x y z)
(cond ((not (< y x)) z)
(t (tak41 (tak17 (1- x) y z)
(tak51 (1- y) z x)
(tak97 (1- z) x y)))))
(defun tak41 (x y z)
(cond ((not (< y x)) z)
(t (tak42 (tak54 (1- x) y z)
(tak62 (1- y) z x)
(tak14 (1- z) x y)))))
(defun tak42 (x y z)
(cond ((not (< y x)) z)
(t (tak43 (tak91 (1- x) y z)
(tak73 (1- y) z x)
(tak31 (1- z) x y)))))
(defun tak43 (x y z)
(cond ((not (< y x)) z)
(t (tak44 (tak28 (1- x) y z)
(tak84 (1- y) z x)
(tak48 (1- z) x y)))))
(defun tak44 (x y z)
(cond ((not (< y x)) z)
(t (tak45 (tak65 (1- x) y z)
(tak95 (1- y) z x)
(tak65 (1- z) x y)))))
(defun tak45 (x y z)
(cond ((not (< y x)) z)
(t (tak46 (tak2 (1- x) y z)
(tak6 (1- y) z x)
(tak82 (1- z) x y)))))
(defun tak46 (x y z)
(cond ((not (< y x)) z)
(t (tak47 (tak39 (1- x) y z)
(tak17 (1- y) z x)
(tak99 (1- z) x y)))))
(defun tak47 (x y z)
(cond ((not (< y x)) z)
(t (tak48 (tak76 (1- x) y z)
(tak28 (1- y) z x)
(tak16 (1- z) x y)))))
(defun tak48 (x y z)
(cond ((not (< y x)) z)
(t (tak49 (tak13 (1- x) y z)
(tak39 (1- y) z x)
(tak33 (1- z) x y)))))
(defun tak49 (x y z)
(cond ((not (< y x)) z)
(t (tak50 (tak50 (1- x) y z)
(tak50 (1- y) z x)
(tak50 (1- z) x y)))))
(defun tak50 (x y z)
(cond ((not (< y x)) z)
(t (tak51 (tak87 (1- x) y z)
(tak61 (1- y) z x)
(tak67 (1- z) x y)))))
(defun tak51 (x y z)
(cond ((not (< y x)) z)
(t (tak52 (tak24 (1- x) y z)
(tak72 (1- y) z x)
(tak84 (1- z) x y)))))
(defun tak52 (x y z)
(cond ((not (< y x)) z)
(t (tak53 (tak61 (1- x) y z)
(tak83 (1- y) z x)
(tak1 (1- z) x y)))))
(defun tak53 (x y z)
(cond ((not (< y x)) z)
(t (tak54 (tak98 (1- x) y z)
(tak94 (1- y) z x)
(tak18 (1- z) x y)))))
(defun tak54 (x y z)
(cond ((not (< y x)) z)
(t (tak55 (tak35 (1- x) y z)
(tak5 (1- y) z x)
(tak35 (1- z) x y)))))
(defun tak55 (x y z)
(cond ((not (< y x)) z)
(t (tak56 (tak72 (1- x) y z)
(tak16 (1- y) z x)
(tak52 (1- z) x y)))))
(defun tak56 (x y z)
(cond ((not (< y x)) z)
(t (tak57 (tak9 (1- x) y z)
(tak27 (1- y) z x)
(tak69 (1- z) x y)))))
(defun tak57 (x y z)
(cond ((not (< y x)) z)
(t (tak58 (tak46 (1- x) y z)
(tak38 (1- y) z x)
(tak86 (1- z) x y)))))
(defun tak58 (x y z)
(cond ((not (< y x)) z)
(t (tak59 (tak83 (1- x) y z)
(tak49 (1- y) z x)
(tak3 (1- z) x y)))))
(defun tak59 (x y z)
(cond ((not (< y x)) z)
(t (tak60 (tak20 (1- x) y z)
(tak60 (1- y) z x)
(tak20 (1- z) x y)))))
(defun tak60 (x y z)
(cond ((not (< y x)) z)
(t (tak61 (tak57 (1- x) y z)
(tak71 (1- y) z x)
(tak37 (1- z) x y)))))
(defun tak61 (x y z)
(cond ((not (< y x)) z)
(t (tak62 (tak94 (1- x) y z)
(tak82 (1- y) z x)
(tak54 (1- z) x y)))))
(defun tak62 (x y z)
(cond ((not (< y x)) z)
(t (tak63 (tak31 (1- x) y z)
(tak93 (1- y) z x)
(tak71 (1- z) x y)))))
(defun tak63 (x y z)
(cond ((not (< y x)) z)
(t (tak64 (tak68 (1- x) y z)
(tak4 (1- y) z x)
(tak88 (1- z) x y)))))
(defun tak64 (x y z)
(cond ((not (< y x)) z)
(t (tak65 (tak5 (1- x) y z)
(tak15 (1- y) z x)
(tak5 (1- z) x y)))))
(defun tak65 (x y z)
(cond ((not (< y x)) z)
(t (tak66 (tak42 (1- x) y z)
(tak26 (1- y) z x)
(tak22 (1- z) x y)))))
(defun tak66 (x y z)
(cond ((not (< y x)) z)
(t (tak67 (tak79 (1- x) y z)
(tak37 (1- y) z x)
(tak39 (1- z) x y)))))
(defun tak67 (x y z)
(cond ((not (< y x)) z)
(t (tak68 (tak16 (1- x) y z)
(tak48 (1- y) z x)
(tak56 (1- z) x y)))))
(defun tak68 (x y z)
(cond ((not (< y x)) z)
(t (tak69 (tak53 (1- x) y z)
(tak59 (1- y) z x)
(tak73 (1- z) x y)))))
(defun tak69 (x y z)
(cond ((not (< y x)) z)
(t (tak70 (tak90 (1- x) y z)
(tak70 (1- y) z x)
(tak90 (1- z) x y)))))
(defun tak70 (x y z)
(cond ((not (< y x)) z)
(t (tak71 (tak27 (1- x) y z)
(tak81 (1- y) z x)
(tak7 (1- z) x y)))))
(defun tak71 (x y z)
(cond ((not (< y x)) z)
(t (tak72 (tak64 (1- x) y z)
(tak92 (1- y) z x)
(tak24 (1- z) x y)))))
(defun tak72 (x y z)
(cond ((not (< y x)) z)
(t (tak73 (tak1 (1- x) y z)
(tak3 (1- y) z x)
(tak41 (1- z) x y)))))
(defun tak73 (x y z)
(cond ((not (< y x)) z)
(t (tak74 (tak38 (1- x) y z)
(tak14 (1- y) z x)
(tak58 (1- z) x y)))))
(defun tak74 (x y z)
(cond ((not (< y x)) z)
(t (tak75 (tak75 (1- x) y z)
(tak25 (1- y) z x)
(tak75 (1- z) x y)))))
(defun tak75 (x y z)
(cond ((not (< y x)) z)
(t (tak76 (tak12 (1- x) y z)
(tak36 (1- y) z x)
(tak92 (1- z) x y)))))
(defun tak76 (x y z)
(cond ((not (< y x)) z)
(t (tak77 (tak49 (1- x) y z)
(tak47 (1- y) z x)
(tak9 (1- z) x y)))))
(defun tak77 (x y z)
(cond ((not (< y x)) z)
(t (tak78 (tak86 (1- x) y z)
(tak58 (1- y) z x)
(tak26 (1- z) x y)))))
(defun tak78 (x y z)
(cond ((not (< y x)) z)
(t (tak79 (tak23 (1- x) y z)
(tak69 (1- y) z x)
(tak43 (1- z) x y)))))
(defun tak79 (x y z)
(cond ((not (< y x)) z)
(t (tak80 (tak60 (1- x) y z)
(tak80 (1- y) z x)
(tak60 (1- z) x y)))))
(defun tak80 (x y z)
(cond ((not (< y x)) z)
(t (tak81 (tak97 (1- x) y z)
(tak91 (1- y) z x)
(tak77 (1- z) x y)))))
(defun tak81 (x y z)
(cond ((not (< y x)) z)
(t (tak82 (tak34 (1- x) y z)
(tak2 (1- y) z x)
(tak94 (1- z) x y)))))
(defun tak82 (x y z)
(cond ((not (< y x)) z)
(t (tak83 (tak71 (1- x) y z)
(tak13 (1- y) z x)
(tak11 (1- z) x y)))))
(defun tak83 (x y z)
(cond ((not (< y x)) z)
(t (tak84 (tak8 (1- x) y z)
(tak24 (1- y) z x)
(tak28 (1- z) x y)))))
(defun tak84 (x y z)
(cond ((not (< y x)) z)
(t (tak85 (tak45 (1- x) y z)
(tak35 (1- y) z x)
(tak45 (1- z) x y)))))
(defun tak85 (x y z)
(cond ((not (< y x)) z)
(t (tak86 (tak82 (1- x) y z)
(tak46 (1- y) z x)
(tak62 (1- z) x y)))))
(defun tak86 (x y z)
(cond ((not (< y x)) z)
(t (tak87 (tak19 (1- x) y z)
(tak57 (1- y) z x)
(tak79 (1- z) x y)))))
(defun tak87 (x y z)
(cond ((not (< y x)) z)
(t (tak88 (tak56 (1- x) y z)
(tak68 (1- y) z x)
(tak96 (1- z) x y)))))
(defun tak88 (x y z)
(cond ((not (< y x)) z)
(t (tak89 (tak93 (1- x) y z)
(tak79 (1- y) z x)
(tak13 (1- z) x y)))))
(defun tak89 (x y z)
(cond ((not (< y x)) z)
(t (tak90 (tak30 (1- x) y z)
(tak90 (1- y) z x)
(tak30 (1- z) x y)))))
(defun tak90 (x y z)
(cond ((not (< y x)) z)
(t (tak91 (tak67 (1- x) y z)
(tak1 (1- y) z x)
(tak47 (1- z) x y)))))
(defun tak91 (x y z)
(cond ((not (< y x)) z)
(t (tak92 (tak4 (1- x) y z)
(tak12 (1- y) z x)
(tak64 (1- z) x y)))))
(defun tak92 (x y z)
(cond ((not (< y x)) z)
(t (tak93 (tak41 (1- x) y z)
(tak23 (1- y) z x)
(tak81 (1- z) x y)))))
(defun tak93 (x y z)
(cond ((not (< y x)) z)
(t (tak94 (tak78 (1- x) y z)
(tak34 (1- y) z x)
(tak98 (1- z) x y)))))
(defun tak94 (x y z)
(cond ((not (< y x)) z)
(t (tak95 (tak15 (1- x) y z)
(tak45 (1- y) z x)
(tak15 (1- z) x y)))))
(defun tak95 (x y z)
(cond ((not (< y x)) z)
(t (tak96 (tak52 (1- x) y z)
(tak56 (1- y) z x)
(tak32 (1- z) x y)))))
(defun tak96 (x y z)
(cond ((not (< y x)) z)
(t (tak97 (tak89 (1- x) y z)
(tak67 (1- y) z x)
(tak49 (1- z) x y)))))
(defun tak97 (x y z)
(cond ((not (< y x)) z)
(t (tak98 (tak26 (1- x) y z)
(tak78 (1- y) z x)
(tak66 (1- z) x y)))))
(defun tak98 (x y z)
(cond ((not (< y x)) z)
(t (tak99 (tak63 (1- x) y z)
(tak89 (1- y) z x)
(tak83 (1- z) x y)))))
(defun tak99 (x y z)
(cond ((not (< y x)) z)
(t (tak0 (tak0 (1- x) y z)
(tak0 (1- y) z x)
(tak0 (1- z) x y)))))
;;; TPRINT -- Benchmark to print and read to the terminal.
(defvar test-atoms '(abc1 cde2 efg3 ghi4 ijk5 klm6 mno7 opq8 qrs9
stu0 uvw1 wxy2 xyz3 123a 234b 345c 456d
567d 678e 789f 890g))
(defvar test-pattern (init 6. 6. test-atoms))
(defun init (m n atoms)
(let ((atoms (subst () () atoms)))
(do ((a atoms (cdr a)))
((null (cdr a)) (rplacd a atoms)))
(init-aux m n atoms)))
(defun init-aux (m n atoms)
(cond ((= m 0) (pop atoms))
(t (do ((i n (- i 2))
(a ()))
((< i 1) a)
(push (pop atoms) a)
(push (init-aux (1- m) n atoms) a)))))
(deftimer tprint (print test-pattern)) ; ZetaLisp timer
;;; TRAVERSE -- Benchmark which creates and traverses a tree structure.
;; this macro was in the original program. MOD will be a CL fn.
(defmacro mod (x n) `(remainder ,x ,n))
;; TRAVERSE bench begins here
(defstruct node
(parents ())
(sons ())
(sn (snb))
(entry1 ())
(entry2 ())
(entry3 ())
(entry4 ())
(entry5 ())
(entry6 ())
(mark ()))
(defvar sn 0)
(defvar rand 21.)
(defvar count 0)
(defvar marker nil)
(defvar root)
(defmacro snb ()
`(setq sn (1+ sn)))
(defmacro seed ()
`(setq rand 21.))
(defun traverse-random () (setq rand (mod (* rand 17.) 251.)))
(defun traverse-remove (n q)
(cond ((eq (cdr (car q)) (car q))
(prog2 () (caar q) (rplaca q ())))
((= n 0)
(prog2 () (caar q)
(do ((p (car q) (cdr p)))
((eq (cdr p) (car q))
(rplaca q
(rplacd p (cdr (car q))))))))
(t (do ((n n (1- n))
(q (car q) (cdr q))
(p (cdr (car q)) (cdr p)))
((= n 0) (prog2 () (car q) (rplacd q p)))))))
(defun traverse-select (n q)
(do ((n n (1- n))
(q (car q) (cdr q)))
((= n 0) (car q))))
(defun add (a q)
(cond ((null q)
`(,(let ((x `(,a)))
(rplacd x x) x)))
((null (car q))
(let ((x `(,a)))
(rplacd x x)
(rplaca q x)))
(t (rplaca q
(rplacd (car q) `(,a .,(cdr (car q))))))))
(defun create-structure (n)
(let ((a `(,(make-node))))
(do ((m (1- n) (1- m))
(p a))
((= m 0) (setq a `(,(rplacd p a)))
(do ((unused a)
(used (add (traverse-remove 0 a) ()))
(x) (y))
((null (car unused))
(find-root (traverse-select 0 used) n))
(setq x (traverse-remove (mod (traverse-random) n) unused))
(setq y (traverse-select (mod (traverse-random) n) used))
(add x used)
(setf (sons y) `(,x .,(sons y)))
(setf (parents x) `(,y .,(parents x))) ))
(push (make-node) a))))
(defun find-root (node n)
(do ((n n (1- n)))
((= n 0) node)
(cond ((null (parents node))
(return node))
(t (setq node (car (parents node)))))))
(defun travers (node mark)
(cond ((eq (mark node) mark) ())
(t (setf (mark node) mark)
(setq count (1+ count))
(setf (entry1 node) (not (entry1 node)))
(setf (entry2 node) (not (entry2 node)))
(setf (entry3 node) (not (entry3 node)))
(setf (entry4 node) (not (entry4 node)))
(setf (entry5 node) (not (entry5 node)))
(setf (entry6 node) (not (entry6 node)))
(do ((sons (sons node) (cdr sons)))
((null sons) ())
(travers (car sons) mark)))))
(defun traverse (root)
(let ((count 0))
(travers root (setq marker (not marker)))
count))
;;; end of bench
(timer init-timit ; ZetaLisp timer for initializationn
(prog2 (setq root (create-structure 100.)) ()))
(timer timit ; ZetaLisp timer to run TRAVERSE
(do ((i 50. (1- i)))
((= i 0))
(traverse root)
(traverse root)
(traverse root)
(traverse root)
(traverse root)))
;;; TRIANG --
;; Common Lisp Package for redefining system fns.
(eval-when (load eval compile)
(package-declare CL global 1000
()
(shadow make-array))
(pkg-goto 'CL))
;; Cosmetic patch to MAKE-ARRAY as used in this bench. The White Pages say that
;; the type of the initial-element must match the array type. Ergo(???), you have to
;; declare the array type.
(defsubst cl:make-array (dimensions &optional ignore-type-keyword ignore-type
init-keyword initial-element)
(prog ((arr (global:make-array dimensions)))
(cond (init-keyword (fillarray arr (list initial-element))))
(return arr)))
;; FILLARRAY is called FILL in CL but there are some significant differences in cases
;; where the array length and list length don't match. Fortunately they do match where
;; they are used in this program.
(defmacro cl:fill (array-name fill-list)
`(fillarray ,array-name ,fill-list))
;; I'm using CL's CONCATENATE as a LISTARRAY equivalent. I'd like to know about it
;; if there's a better way to do this. This seems pretty crufty. [pw]
(defmacro cl:concatenate (ignore-type array-name)
`(listarray ,array-name))
;;; TRIANG begins here
(defvar board (make-array 16. ':type ':fixnum ':initial-element 1))
(defvar sequence (make-array 14. ':type ':fixnum ':initial-element 0))
(defvar a (make-array 37.))
(defvar b (make-array 37.))
(defvar c (make-array 37.))
(defvar answer)
(defvar final)
(setf (aref board 5) 0)
(fill a '(1 2 4 3 5 6 1 3 6 2 5 4 11. 12. 13. 7 8. 4
4 7 11. 8. 12. 13. 6 10. 15. 9. 14. 13. 13. 14. 15. 9. 10. 6))
(fill b '(2 4 7 5 8. 9. 3 6 10. 5 9. 8. 12. 13. 14. 8. 9. 5
2 4 7 5 8. 9. 3 6 10. 5 9. 8. 12. 13. 14. 8. 9. 5))
(fill c '(4 7 11. 8. 12. 13. 6 10. 15. 9. 14. 13. 13. 14. 15. 9. 10. 6
1 2 4 3 5 6 1 3 6 2 5 4 11. 12. 13. 7 8. 4))
(defun last-position ()
(do ((i 1 (1+ i)))
((= i 16.) 0)
(cond ((= 1 (aref board i)) (return i)))))
(defun try (i depth)
(cond ((= depth 14)
(let ((lp (last-position)))
(cond ((member lp final))
(t (push lp final))))
(push (cdr (concatenate 'list sequence)) answer) t) ; LISTARRAY equivalent.
((and (= 1 (aref board (aref a i)))
(= 1 (aref board (aref b i)))
(= 0 (aref board (aref c i))))
(setf (aref board (aref a i)) 0)
(setf (aref board (aref b i)) 0)
(setf (aref board (aref c i)) 1)
(setf (aref sequence depth) i)
(do ((j 0 (1+ j))
(depth (1+ depth)))
((or (= j 36.)
(try j depth)) ()))
(setf (aref board (aref a i)) 1)
(setf (aref board (aref b i)) 1)
(setf (aref board (aref c i)) 0) ())))
(defun gogogo (i)
(let ((answer ())
(final ()))
(try i 1)))
;;; end of bench
(user:deftimer triang ; ZetaLisp timing fn.
(cl:gogogo 22.))